PD ROM 1/PD ROM Volume I - Macintosh Software from BMUG (1988).iso/Programming/Programming Tools/Turbo Pascal/Utilities/COMPAT.PAS

Pascal/Delphi Source File | 1987-06-16 | 16.5 KB | 580 lines | [TEXT/ttxt]

unit Compat(56);
{ Implements several "Turbo" routines that are not built into
  Turbo for the Mac.

  Last Edit: 3/25/87
  version 1.00
  written by : Joe Schrader 76703,4161
}
{=================================================================}
interface
uses MemTypes, QuickDraw, OSIntF, ToolIntF;

const
  MacBlockSize = 512;          { Standard block size on Macintosh }
  TurboBlockSize = 128;
              { Set to 128 for compatibility with  implementations of }
                                   { Turbo Pascal  on other machines. }
type
  PackedByte = packed record
                      { this is the easiest way to force a variable }
                      { to occupy 1 byte }
                        b : byte;
                      end;
  UntypedFile = file of PackedByte;  { Block operations are on untyped, }
                                                   { that is, any files }

{ File routines }

procedure Append(var f : text;
                 FN : str255);
{ Opens a text file named by FN, for appending.  That is, this
  routine opens the file and seeks to the end so you can add
  text with Write(f, ...) }

procedure BlockRead(var F : UntypedFile;
                    var Buf;
                        NumBlocks : LongInt;
                    var BlocksRead : LongInt);
{ Reads NumBlocks blocks of data from F into Buf.  BlocksRead
  specifies the number of blocks actually read. }


procedure BlockWrite(var F : UntypedFile;
                    var Buf;
                        NumBlocks : LongInt;
                    var BlocksWritten : LongInt);
{ Writes Numblocks of data from Buf to the file referred to by
  F.  BlocksWritten specifies the actual number of bytes written }

procedure SetBlockSize(var F : UnTypedFile;
                       Size : LongInt);
{ Sets the block size used for all subsequent block operations
  and Seek's used on F. }

procedure EraseF(FileName : String);
{ Since the identifier Erase used in QuickDraw supercedes Turbo's rename,
  you can use this procedure which is simpler than the OS equivalent }


procedure Execute(ProgName : Str255);
{ Executes, launches the program specified by ProgName.  If
  the program is not found this routine will crash, so the
  programmer should check to see if it us, before-hand.
  WARNING: Don't call this routine while running inside of the
  Turbo environment i.e. only use it with a program you run
  from disk
}

function LongFilePos(var F) : real;

function LongFileSize(var F) : real;

procedure LongSeek(var F; SeekPos : real);

procedure RenameF(OldFileNm, NewFileNm : String);
{ Since the Rename procedure in OSIntF supercedes Turbo's rename,
  you can use this procedure which is simpler than the OS equivalent }

function ParamCount : integer;

function ParamStr(Param : integer) : string;

{ Random number routines }

procedure Randomize;
{ Sets the seed for the random number generator using the system
  clock. If you want to seed the generator yourself, just set
  the global variable, Seed directly. }

function Random(Max : LongInt) : LongInt;
{ Returns a "random" Long integer in the range 0..Max }

function RandomR : real;
{ Returns a "random" real number between 0 and 1.  On other
  implementations of Turbo this built-in function is called Random
  like the routine above it.  This cannot be duplicated at the
  Pascal level, however. }

{ General routines }

procedure ClrEol;
{ Clears to the end of the current line.  Simple call-through to routine
  with Lisa Pascal compatible name }

procedure ClrScr;
{ Clears the screen.  Simple call-through to routine with Lisa Pascal
  compatible name }

procedure Delay(DelayTime : LongInt);
{ Delays DelayTime # of milliseconds }

function Frac(Num : real) : real;
{ Returns the fractional part of Num }

procedure FreeMem(var P : Ptr;
                  NumBytes : integer);
{ Reclaims the space allocated to P }

procedure GetMem(var P : Ptr;
                 NumBytes : integer);
{ Allocates Numbytes bytes and set P as a pointer to this block }

procedure NoSound;
{ Turns off the speaker(s) }

procedure Sound(Freq : LongInt);
{ Makes a tone of Freq frequency }

function UpCase(ch : char): char;
{ Returns the upper case equivalent of ch }
inline
   $301F, { UpCase MOVE.W (SP)+,D0 ; GetCh }
   $0C40,
   $0061, { CMP.W #'a',D0 ; skip if not lower case }
   $6D0A, { BLT.S @1 }
   $0C40,
   $007A, { CMP.W #'z',D0 }
   $6E04, { BGT.S @1 }
   $0440,
   $0020, { SUB.W #$20,D0 }
   $3E80; { @1 MOVE.W D0,(SP) }

function WhereX : integer;
{ Returns the current X coordinate in PasConsole. Note: this only
  works with the default font. }

function WhereY : integer;
{ Returns the current Y coordinate in PasConsole. Note: this only
  works with the default font. }

var
  CON,        { File variable associated with console device driver }
  LST,        { "                          "  the printer }
  KBD : text; { "                          " the keyboard device }
  Seed : LongInt; { Seed for the random number generator }
{=================================================================}
implementation
var
  FileErr : OSErr;

{ The following type declarations represent the internal format of
  a Turbo file variable (covered on page 330 of the Turbo for the Mac
  Reference Manual).  For the file manager calls we need the file
  reference number.  To access the fields in a file variable we map
  the record structure using value casting, for eg. FileRec(F),
   which is covered on page 244.}
type
  FileBuf = packed array[0..MaxInt] of char;
  FileBufferPtr = ^FileBuf;
  ProcPtr = ^Integer;
  FileRec = record    { Internal format of a Turbo file variable }
              FInpFlag : boolean;
              FOutFlag : boolean;
              FRefNum : integer;  { Reference number is used for }
              FVRefNum : integer;       { Mac File Manager calls }
              FBufSize : integer;
              FBufPos : integer;
              FBufEnd : integer;
              FBuffer : FileBufferPtr;
              FInOutProc : ProcPtr;
            end;

function Exists(FN : String) : boolean;
var
  F : UntypedFile;
  Ok : boolean;
begin
{$I-}
 Reset(F, FN);
 Ok := (IOResult = 0);
 {$I+}
 if Ok then
   Close(F);
 Exists := Ok;
end; { Exists }

procedure Append{var f : text;
                 FN : str255};
{ Opens a text file named by FN, for appending.  That is, this
  routine opens the file and seeks to the end so you can add
  text with Write(f, ...) }
begin
  if not Exists(FN) then
  begin
    Rewrite(F, FN);
    Exit;
  end;
  Reset(f, Fn);
  with FileRec(f) do
  begin
    FInpFlag := false;
    FOutFlag := true;
    FileErr := SetFPos(FRefNum, FsFromLEOF, 1);
    if (FileErr <> NoErr) and (FileErr <> EofErr)  then
      SysError(-FileErr);
  end;
end; { Append }

procedure BlockRead{var F : UntypedFile;
                    var Buf;
                        NumBlocks : LongInt
                    var BlocksRead : LongInt};
{ Reads NumBlocks blocks of data from F into Buf.  BlocksRead
  specifies the number of blocks actually read. }

begin
  with FileRec(F) do { Type cast file variable so we can access fields }
  begin
    BlocksRead := NumBlocks * FBufSize;  { Get the # of bytes to read }
    if BlocksRead > 0 then
    begin
      FileErr := FSRead(FRefNum, BlocksRead, @Buf);
      if (FileErr <> NoErr) and (FileErr <> EofErr) then
        SysError(-FileErr);
      BlocksRead := BlocksRead div FBufSize; { Convert to # of blocks }
    end;
  end;
end; { BlockRead }

procedure BlockWrite{var F : UntypedFile;
                     var Buf;
                        NumBlocks : LongInt;
                     var BlocksWritten : LongInt};
{ Writes Numblocks of data from Buf to the file referred to by
  F.  BlocksWritten specifies the actual number of bytes written }
begin
  with FileRec(F) do   { Type cast file variable so we can access fields }
  begin
    BlocksWritten := NumBlocks * FBufSize; { Get the # of bytes to read }
    if BlocksWritten > 0 then
    begin
      FileErr := FSWrite(FRefNum, BlocksWritten, @Buf);    { OSIntf call }
      if (FileErr <> NoErr) then
        SysError(-FileErr);
      BlocksWritten := BlocksWritten div FBufSize;
                                                { Convert to # of blocks }
    end;
  end;
end; { BlockWrite }

procedure SetBlockSize{var F : UnTypedFile;
                       Size : LongInt};
{ Sets the block size used for all subsequent block operations
  (until another SetBlockSize is used), note: this procedure need
  not be called }
begin
  with FileRec(F) do
  FBufSize := Size;
end; { SetBlockSize }

procedure EraseF{FileName : String};
{ Since the identifier Erase used in QuickDraw supercedes Turbo's rename,
  you can use this procedure which is simpler than the OS equivalent }
begin
  FileErr := FSDelete(FileName, 0);
  if (FileErr <> NoErr) and (FileErr <> FnFErr) then
  { If error this will generates a bomb box }
    SysError(-FileErr); { Resume and Turbo will find error, if in memory }
end; { EraseF }

procedure Execute{ProgName : Str255};
{ Executes, launches the program specified by ProgName.  If
  the program is not found this routine will crash, so the
  programmer should check to see if it exists, before-hand.
  WARNING: Don't call this routine while running inside of the
  Turbo environment i.e. only use it with a program you run
  from disk
}
type
  LaunchRec = record
                ProgramName : ^Str255; { pointer to the program name }
                SoundBuffer : integer; { indicates which buffers to use }
              end;
  { The variables in this record make it easy for the inline
    routine below to call the launch trap }

procedure LaunchIt(var LaunchVar : LaunchRec);
{ The Launch routine can only be called from assembler.
  So below is the strip of inline code that accomplishes
  that. For more information see Inside Macintosh II 59-60.
  On entry (to launch trap macro):
    (A0): points to applications file name
    4(A0):configuration of sound and screen buffer
}
inline
  $205F,   { MOVE.L  (SP)+,A0 } { move paramater into A0 }
  $A9F2;            { _Launch }
var
  LaunchVar : LaunchRec;
  F : file of byte;
  Name : Str255;

begin
  Reset(F, ProgName);  { This is called so the program will crash here }
                        { if the file is not there, rather than on the }
                           { launch, which gives unpredictable results }
  Close(F);
  Name := ProgName;
  with LaunchVar do
  begin
    SoundBuffer := 0;
    { uses Main sound and screen buffers.  If you want the current
      buffer, you need to write inline to get it from the variable
      CurPageOption.  I have not done this yet. }
    ProgramName := @Name;
  end;
  LaunchIt(LaunchVar);
end; { Execute }


function LongFilePos{(var F) : real};
var
  FileErr : OSErr;
  FPos : LongInt;
begin
  with FileRec(F) do
  begin
    FileErr := GetFPos(FRefNum, FPos);
    if (FileErr <> NoErr) then
      SysError(-FileErr);
    LongFilePos := FPos div FBufSize;
  end;
end; { LongFilePos }

function LongFileSize{(var F) : real};
var
  FileErr : OSErr;
  FSize : LongInt;
begin
  with FileRec(F) do
  begin
    FileErr := GetEOF(FRefNum, FSize);
    if (FileErr <> NoErr) then
      SysError(-FileErr);
    LongFileSize := FSize div FBufSize;
  end;
end; { LongFileSize }

procedure LongSeek{(var F; SeekPos : real)};
type
  Long = LongInt;
var
  FileErr : OSErr;
  FSize : LongInt;
begin
  with FileRec(F) do
  begin
    FileErr := SetFPos(FRefNum, FsFromStart, Long(SeekPos) * Long(FBufSize));
    if (FileErr <> NoErr) then
      SysError(-FileErr);
  end;
end; { LongSeek }

function ParamCount{ : integer};
var
  Message,
  Count : integer;

begin
  CountAppFiles(Message, Count);
  ParamCount := Count;
end; { ParamCount }

function ParamStr{(Param : integer) : string};
var
  AppFileInfo : AppFile;

begin
  GetAppFiles(Param, AppFileInfo);
  ParamStr := AppFileInfo.FName;
end; { ParamStr }

procedure RenameF{OldFileNm, NewFileNm : String};
{ Since the Rename procedure in OSIntF supercedes Turbo's rename,
  you can use this procedure which is simpler than the OS equivalent }
begin
  FileErr := Rename(OldFileNm, 0, NewFileNm);
  if FileErr <> NoErr then  { If error this will generates a bomb box }
    SysError(-FileErr); { Resume and Turbo will find error, if in memory }
end; { RenameF }

{ Random number routines }

procedure Randomize;
{ Sets the seed for the random number generator using the system
  clock. If you want to seed the generator yourself, just set
  the global variable, Seed directly. }
begin
  Seed := TickCount;
end; { Randomize }

function Random{(Max : LongInt) : LongInt};
{ Returns a "random" Long integer in the range 0..Max }
begin
  Seed := (Seed * $81)+$361862E9; { next value for the seed }
  Random := (Seed SHR 16) MOD Max;
end;

function RandomR{ : real};
{ Returns a "random" real number between 0 and 1.  On other
  implementations of Turbo this function is called Random
  like the routine above it.  This cannot be duplicated at
  the Pascal level, however. }
var
  r : real;
begin
  Seed := (Seed * $81)+$361862E9;
  r := Seed;
  RandomR := abs(r) / 2147483648.0;
end; { RandomR }

{ General routines }

procedure ClrEol;
{ Clears to the end of the current line.  Simple call through to routine
  with Lisa Pascal compatible name }
begin
  ClearEol;
end; { ClrEol }

procedure ClrScr;
{ Clears the screen.  Simple call through to routine with
  Lisa Pascal compatible name }
begin
  ClearScreen;
end; { ClrScr }

procedure Delay{DelayTime : LongInt};
{ Delays DelayTime # of milliseconds }

procedure DelayIt(ticks: Longint); inline $205F,$A03B;

begin { Delay }
  DelayTime := DelayTime div 17;
  if DelayTime > 0 then
    DelayIt(DelayTime);
end; { Delay }

function Frac{(Num : real) : real};
{ Returns the fractional part of Num }
begin
  Frac := Num - Int(Num);
end;

procedure FreeMem{var P : Ptr;
                  NumBytes : integer};
{ Reclaims the space allocated to P }
begin
  Dispose(p);
end; { FreeMem }

procedure GetMem{var P : Ptr;
                 NumBytes : integer};
{ Allocates Numbytes bytes and set P as a pointer to this block }
begin
  P := NewPtr(Numbytes);
end; { GetMem }

procedure NoSound;
{ Turns off the speaker(s) }
begin
  StopSound;
end;

procedure Sound{Freq : LongInt};
{ Makes a tone of Freq frequency }
const
   FreqItem = 4;
   BufSize  = 8;

 var
   count    : integer;
   mySwPtr  : SWSynthPtr;
   myHandle : Handle;
   myPtr    : Ptr;

begin
  count := 783360 div freq;
  myHandle := newHandle(BufSize);
  Hlock(myHandle);
  myPtr := myHandle^;
  mySwPtr := SWSynthPtr(myPtr);
  with mySwPtr^ do
  begin
    mode := swmode; { use sine wave mode }
    triplets[0].count := count;
    triplets[0].amplitude := 127;
    triplets[0].duration := 60;
  end;
  StartSound(myPtr, BufSize, pointer(-1));
  HUnlock(myHandle);
  DisposHandle(myHandle);
end; { Sound }

function WhereX{ : integer};
{ Returns the current X coordinate in PasConsole. Note: this only
  works with the default font. }
begin
  with thePort^ do
    WhereX := PnLoc.h div 6;
end;

function WhereY{ : integer};
{ Returns the current Y coordinate in PasConsole. Note: this only
  works with the default font. }
begin
  with thePort^ do
    WhereY := PnLoc.v div 9;
end;


function KBDIn(var F : FileRec) : integer;
{ Implements the KBD device driver for compatibility wit other
  implementations of Turbo Pascal. You can now do Read(KBC, ch).
  Note: this should only be used with CHARACTER variables.  If you
  move this device driver to another unit, also take InitKBD below. }

var
  P : integer;
  ch : char;
begin
  KBDIn := 0;
  with F do
    if FInpFlag then { We will be only outputting with this device }
    begin
      ch := ReadChar;   { ReadChar is equivalent to Read(KBD, ) }
      FBuffer^[0] := ch;
      FBufEnd := 1;
      FBufPos := 0;
    end;
end; { KBDIn }

procedure InitKBD;
{ Call only once at the beginning of the program to initialize
  the KBD device driver. }
begin
  Device('KBD:', @KBDIn);
  Reset(KBD,'KBD:');
  with FileRec(KBD) do
    FBufSize := 1;
end; { InitKBD }

procedure InitDevices;
begin
  InitKBD;
  Rewrite(CON, 'Console:');
  {$I-} { prevents crash if Printer is not there }
  Rewrite(LST, 'Printer:');
  {$I+}
end; { InitDevices }

var
  SavePort : GrafPtr;
begin { Initialization code for the unit }
  GetPort(SavePort);
  InitGraf(@thePort);
  SetPort(SavePort);
  InitDevices; { Initialization routine for device drivers }
end. { Compat }